(*
    - Use the Config section below to set preferences

    Version 5:
        - fixed bug: now compilation errors are reported rather than crash
          the test runner................

    Version 4:
        - fixed command line arguments bug (was running only first arg)
        - a little visual clean up
        - added stats

    Version 3:
        - changed the way we run tests in Petite. Now conforms with the
          official tests

    Version 2:
        - Now we can run tests suites (directories of test cases)
        - Shows available tests if ran with no arguments
        - Less noise when printing messages
*)

use "compiler.sml";

structure TestRunner : sig
    val run: (string list) -> string
    val exitWhenDone : bool
    val version : string
    val verifyConfig : unit -> unit
    exception ConfigError of string
    val availableTests : unit -> string list
    val display : string -> unit;
    val displayStats : unit -> unit;
end = struct

(* ******************************************************************* Config *)
val exitWhenDone = true;        (* true <==> exit SML when all tests are done *)

structure ThisOS = struct
(*  val pathPetite = "/usr/bin/petite"; *)
    val pathPetite = "./run-tc-petite.sh";
    val pathMake = "/usr/bin/make";                  (* full path of GNU make *)

    val execute = Unix.execute;
    type proc = (TextIO.instream,TextIO.outstream) Unix.proc;
    val reap = Unix.reap;
    val textInstreamOf = Unix.textInstreamOf;

    (* fun mkPath (parts : string list) : string = "";
       todo: implement and use *)
end;
(* ************************************************************************** *)

val version = "5";

val dirC   = "./tests/c";
val dirScm = "./tests/scm";
val dirExe = "./tests/exe";
(* val dirPet = "./tests/petite"; *)

structure Stats = struct
    val total = ref 0;
    val passed = ref 0;
    val alike = ref 0;
    val failed = ref 0;
    val errors = ref 0;

    fun toString () = "Total : "^(Int.toString (!total))^"\n"^
                      "Passed: "^(Int.toString (!passed + !alike))^" ("^(Int.toString (!alike))^" of them with only similar results)\n"^
                      "Failed: "^(Int.toString (!failed))^"\n"^
                      "Error : "^(Int.toString (!errors))^"\n";
end;

exception ConfigError of string;
exception CompileCToExecError of string;
exception ExecError of string;
exception ExecRealError of string;

type ExecResult = (OS.Process.status * string);

datatype TestResult = Pass of string
                    | PassAlike of string * string * string
                    | AssertionFailed of string * string * string
                    | UnexpectedError of string * string;

fun testResultToString (Pass tcname) = "passed: "^tcname
  | testResultToString (PassAlike (tcname,actual,expected)) = "passed: "^tcname^"\n"^
                                                              "   however, got: "^actual^
                                                              "   instead   of: "^expected
  | testResultToString (AssertionFailed (tcname,actual,expected)) = "FAILED: "^tcname^"\n"^
                                                                    "   Got:      "^actual^
                                                                    "   Expected: "^expected
  | testResultToString (UnexpectedError (tcname,str)) = "ERROR: "^tcname^"\n"^
                                                        "   "^str^"\n";

fun display msg =
    let
        val isNewline = fn #"\n"=>true | _=>false
    in
        print ("###### "^
               (String.concatWith "\n###### " (String.fields isNewline msg))^
               "\n"
              )
    end;

fun displayStats () = display (Stats.toString ());

fun mapDir f dir =
    case OS.FileSys.readDir dir of
        SOME name => (f name) :: (mapDir f dir)
      | NONE => [];

fun verifyConfig () =
   (OS.FileSys.access (dirC,[OS.FileSys.A_READ,OS.FileSys.A_WRITE])
        orelse raise ConfigError ("cannot read/write: "^dirC)
   ;OS.FileSys.access (dirScm,[OS.FileSys.A_READ])
        orelse raise ConfigError ("cannot read: "^dirScm)
   ;OS.FileSys.access (dirExe,[OS.FileSys.A_WRITE,OS.FileSys.A_EXEC])
        orelse raise ConfigError ("cannot write/exec: "^dirExe)
(*
   ;OS.FileSys.access (dirPet,[OS.FileSys.A_READ,OS.FileSys.A_WRITE])
        orelse raise ConfigError ("cannot read/write: "^dirPet)
*)
   ;OS.FileSys.access (ThisOS.pathPetite,[OS.FileSys.A_EXEC])
        orelse raise ConfigError ("cannot exec: "^ThisOS.pathPetite)
   ;OS.FileSys.access (ThisOS.pathMake,[OS.FileSys.A_EXEC])
        orelse raise ConfigError ("cannot exec: "^ThisOS.pathMake)
   ;OS.FileSys.access ("makefile",[OS.FileSys.A_READ])
        orelse raise ConfigError ("no makefile")
   ; ()
   )

(* Returns a list of available tests *)
fun availableTests() =
    let val dir = OS.FileSys.openDir dirScm
        val tests = mapDir (fn name=>name) dir
        val _ = OS.FileSys.closeDir dir
    in
        tests
    end

(* Returns a concatenation of all the lines from the input stream *)
fun readAllLines (instrm : TextIO.instream) : string =
    let
        val line = TextIO.inputLine instrm
    in case line of
        SOME str => str ^ readAllLines instrm
      | NONE => ""
    end;

(* Executes a file (`exename`, with arguments `args`) and returns the status
   and (standard) output of the execution *)
fun captureOutputOf (exename : string, args : string list) : ExecResult =
    let
        val p = ThisOS.execute (exename, args) : ThisOS.proc
        val instrm = ThisOS.textInstreamOf p
        val output = readAllLines instrm
        val status = ThisOS.reap p
    in (status,output) end;

(* Creates the directories needed to access the filename, including parent
   directories *)
fun mkDirsFor filename =
    (* already exsists? nothing to do *)
    if OS.FileSys.access (filename,[]) then ()
    else
        let
            (* remove the file name (last element) - keep only directories *)
            val dirElements = List.rev (tl (List.rev (String.tokens isDirSeperator filename)))
        in
            mkPath "" dirElements
        end
(* Creates the path made of the elements in arg2. arg1 is the already-existing
   part of the path *)
and mkPath _ [] = ()
  | mkPath "" (first :: rest) =
       (if OS.FileSys.access (first,[]) = false then
            OS.FileSys.mkDir first
        else ()
       ;mkPath first rest)
  | mkPath existingPart (newElement :: rest) =
       (if OS.FileSys.access (existingPart^"/"^newElement,[]) = false then
            OS.FileSys.mkDir (existingPart^"/"^newElement)
        else ()
       ;mkPath (existingPart^"/"^newElement) rest)
and isDirSeperator #"/" = true
  | isDirSeperator _   = false;

fun stringToFile (filename : string, str : string) =
    let
        val _ = mkDirsFor filename
        val f = TextIO.openOut filename
    in
      ( TextIO.output(f, str);
        TextIO.closeOut f )
    end;

fun fileToString (filename : string) =
    let
        val f = TextIO.openIn filename
        fun loop s =
           (case TextIO.input1 f of
                NONE => s
              | SOME c => loop (c :: s))
        val result = String.implode (rev (loop []))
    in
       (TextIO.closeIn f;
        result)
    end;


fun compileSchemeToC (tcname : string) : unit =
    let
        val infile = dirScm ^ "/" ^ tcname ^ ".scm"
        val outfile = dirC ^ "/" ^ tcname ^ ".c"
        val _ = mkDirsFor outfile
    in
        CodeGen.compileSchemeFile (infile,outfile)
    end;

fun compileCToExec (tcname : string) =
    let
        val infile = dirC^"/"^tcname
        val (status,output) = captureOutputOf (ThisOS.pathMake,[""^infile^""])
        val outfile = dirExe^"/"^tcname
        val _ = mkDirsFor outfile
    in
        if OS.Process.isSuccess status then
           (
            OS.FileSys.rename {old=infile, new=outfile};
            output)
        else
            raise CompileCToExecError "see errors above"
    end;

(* Runs the compiled executable *)
fun runTestCase (tcname : string) : string =
    let
        val (status,output) = captureOutputOf (dirExe ^ "/" ^ tcname, [])
    in
        if OS.Process.isSuccess status then
            output
        else
            raise ExecError "see errors above"
    end;

(* Runs the test case in Petite Chez Scheme *)
fun runInPetite (tcname:string):string =
    let
        val (status,output) = captureOutputOf (ThisOS.pathPetite,[tcname])
    in
        if OS.Process.isSuccess status then
            output
        else
            raise ExecRealError "see errors above"
    end;

(* - Compiles the test (Scheme->C->exec)
   - Runs the test
   - Runs the test in Petite Chez Scheme
   - Compares the results *)
fun assert (tcname:string) =
   (Stats.total := !Stats.total + 1;
    display ("\ttest-case: "^tcname);
    compileSchemeToC tcname;
    compileCToExec tcname;
    let
        val actual = runTestCase tcname
        val expected = runInPetite tcname
    in
        if actual=expected then
            (Stats.passed := !Stats.passed + 1
            ; Pass tcname
            )
        else if areResultsAlike(actual,expected) then
            (Stats.alike := !Stats.alike + 1
            ;PassAlike (tcname,actual,expected)
            )
        else
            (Stats.failed := !Stats.failed + 1
            ;AssertionFailed (tcname,actual,expected)
            )
    end
   ) handle ex =>
        (Stats.errors := !Stats.errors + 1
        ;case ex of
            CompileCToExecError (msg) => UnexpectedError (tcname,"error while compiling c->exec: "^msg)
          | ExecError (msg) => UnexpectedError (tcname,"error while executing: "^msg)
          | ExecRealError (msg) => UnexpectedError (tcname,"error while executing petite: "^msg)
          | OS.SysErr (msg,_) => UnexpectedError (tcname,"system error: "^msg)
          | IO.Io {cause,function,name} => UnexpectedError (tcname,(exnMessage cause)^" "^name)
          | exn => UnexpectedError (tcname,(exnMessage exn))
        )
and areResultsAlike(actual,expected) =
    ((String.isPrefix "#<compiled closure>" actual) andalso
     (String.isPrefix "#<procedure" expected))
    orelse
    false
;

(* Runs the specified tests (either test-cases or test-suites) *)
fun run [] = ""
  | run (tcname :: rest) =
        (if OS.FileSys.access (dirScm^"/"^tcname,[]) andalso
           OS.FileSys.isDir (dirScm^"/"^tcname) then
            let val dir = OS.FileSys.openDir (dirScm^"/"^tcname)
                val result = runAllInDir (tcname,dir)
            in (OS.FileSys.closeDir dir; result) end
         else
            testResultToString (assert tcname) ^ "\n") ^
        (run rest)
and runAllInDir (suite,dir) =
    String.concat (mapDir (fn(name)=>run [suite^"/"^(trimSuffix ".scm" name)]) dir)
and trimSuffix suffix str =
    if String.isSuffix suffix str then
        String.substring (str, 0, (String.size str)-(String.size suffix))
    else
        str;

end;

TestRunner.display ("TestRunner: you are using version "^TestRunner.version);

TestRunner.verifyConfig()
handle TestRunner.ConfigError msg =>
        (TestRunner.display ("check your configuraion: "^msg)
        ;OS.Process.exit OS.Process.success : unit
        );

val args = CommandLine.arguments ();

if args=[] then
    TestRunner.display ("Available tests:\n\t"^
                        (String.concatWith "\n\t" (TestRunner.availableTests()))^"\n"^
                        "To run them use:\nsml run-tc.sml TEST_NAME")
else (
    TestRunner.display ("\n\nStarting tests:")
   ;let val result = TestRunner.run args
    in
        (TestRunner.display ("\n\nSummary:\n"^result^"\n\n")
        ;TestRunner.displayStats ()
        )
    end
);

if TestRunner.exitWhenDone then
    (OS.Process.exit OS.Process.success : unit)
else
    ()
